PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/basic/databas.com/DATABASE.BAS

BASIC Source File | 1989-05-21 | 28.7 KB | 1,017 lines

' DATABASE.BAS
' Program to test database programming routines - Jose Garcia 04/1989
' <ESC> almost anywhere in the program returns you to the main menu
' See DATABASE.DOC for more documentation other than the comments
' ****
' NOTE use QB /AH to start QuickBASIC as memory arrays are put into the
' **** far heap as dynamic arrays outside the 64K BASIC limits

CONST false% = 0, true% = NOT false%

DECLARE FUNCTION finddeleted% (getnum%)
DECLARE FUNCTION nospace$ (searchstring$)
DECLARE FUNCTION search% (whatText$)

DECLARE SUB border ()
DECLARE SUB box (tr%, br%, lc%, rc%, bars%)
DECLARE SUB center (whichline, text$)
DECLARE SUB dataentry ()
DECLARE SUB db.index ()
DECLARE SUB form ()
DECLARE SUB delete ()
DECLARE SUB displaydata ()
DECLARE SUB edit ()
DECLARE SUB endit ()
DECLARE SUB getname ()
DECLARE SUB txt.edit (temps$(), fieldrow%, fieldcol%, flag%)
DECLARE SUB highlight ()
DECLARE SUB menucall ()
DECLARE SUB lowlight ()
DECLARE SUB menu (fgd, bkgd, brdr)
DECLARE SUB message ()
DECLARE SUB openfile ()
DECLARE SUB openindex ()
DECLARE SUB pause ()
DECLARE SUB reindex (target$)
DECLARE SUB sort ()
DECLARE SUB switch (number%)
DECLARE SUB updatendx ()
DECLARE SUB yesorno ()

TYPE address                'initializes data file fields
  first AS STRING * 10
  last AS STRING * 15
  address1 AS STRING * 25
  address2 AS STRING * 30
  recnum AS INTEGER
END TYPE

TYPE indexrecord            ' initializes index file fields
  firstlast AS STRING * 30
  recordnumber AS INTEGER
  pointer AS INTEGER
END TYPE

OPTION BASE 1
COMMON SHARED index() AS indexrecord, temp()  AS indexrecord
'$DYNAMIC
DIM SHARED names AS address, temps$(4), choice%, m$(5), np%, yn$
DIM SHARED numberofrecords%, recordnumber%, counter%, found.deleted%
DIM SHARED temprow%, comma$, target$, nf%, nb%, rf%, rb%
comma$ = CHR$(44) + CHR$(32)
ON ERROR GOTO errorhandler
openfile

top:
menucall

errorhandler:
SELECT CASE ERR
  CASE 53
    db.index
    RESUME top
  CASE ELSE
    COLOR 20, 7
    BEEP
    LOCATE 25, 1
    PRINT "ERROR NUMBER -> "; ERR; " has occured.  Check program code";
    pause
    RESUME top
END SELECT
RESUME top

REM $STATIC
SUB border
LOCATE 25, 1
COLOR 15, 4
PRINT SPACE$(80);
LOCATE 1, 1
PRINT SPACE$(160);

END SUB

SUB box (tr%, br%, lc%, rc%, bars%)

' This is a generic routine that can be used to draw a box anywhere.
' tr% is the top row. lc% is the beginning left column.
' br% is the bottom row. rc% is the ending right column.
' The paramater bars%, set to 2, prints horizontal bars
' three rows down from the top of the box and two rows up from the bottom.
' If bars% is set to 1, the routine will print an outlined box.
' If bars% is set to 0, just a plain box is printed (be sure to change color
' before the call to box so that the box will be visible).

  middle% = rc% - lc%
  lines% = tr%
  boxside$ = CHR$(186)
  boxtop% = (rc% - lc%) - 1
  boxtop$ = CHR$(201) + STRING$(boxtop%, 205) + CHR$(187)
  boxbottom$ = CHR$(200) + STRING$(boxtop%, 205) + CHR$(188)
  midbox$ = CHR$(204) + STRING$(boxtop%, 205) + CHR$(185)
  FOR boxsize% = tr% TO br%
    LOCATE lines%, lc%, 0
    PRINT SPACE$(middle%);
    lines% = lines% + 1
  NEXT
  IF bars% = 0 THEN EXIT SUB
  IF bars% = 1 THEN
    LOCATE tr%, lc%
    PRINT boxtop$;
    FOR outline% = tr% + 1 TO br% - 1
      LOCATE outline%, lc%
      PRINT boxside$;
      LOCATE outline%, rc%
      PRINT boxside$;
    NEXT outline%
    LOCATE br%, lc%
    PRINT boxbottom$;
  END IF
  IF bars% = 2 THEN   'Prints optional top and bottom bars in box
     LOCATE tr% + 3, lc%: PRINT midbox$;
     LOCATE br% - 2, lc%: PRINT midbox$;
  END IF

END SUB

SUB center (whichline, text$)
 'This is a simple routine that centers a string of text text$
 'on line number WHICHLINE.

  text% = LEN(text$)
  text% = INT((80 - text%) / 2)
  LOCATE whichline, text%
  PRINT text$;

END SUB

SUB dataentry
' The TYPE variables are assigned to the array temps$(),
' txt.edit is called for data entry, then the temporary array variables
' are switched back to their TYPE'd names.  The search% function sees if
' the record is already in the index memory array.  The finddeleted% function
' checks for a deleted record and dataentry will put the new record into the
' database record file with the deleted record's record number, thus deleting
' the deleted record physically from the file.  See comments in DELETE sub.
COLOR 15, 1
CLS
message
COLOR 0, 3
form
temps$(1) = names.first
temps$(2) = names.last
temps$(3) = names.address1
temps$(4) = names.address2
recordnumber% = numberofrecords% + 1
txt.edit temps$(), 9, 35, 1
switch recordnumber%

correct:
COLOR 14, 0
LOCATE 17, 32
PRINT "Correct ? Y/N ";
ans$ = INPUT$(1)
IF UCASE$(ans$) = "Y" THEN
  last$ = names.last
  first$ = names.first
  target$ = nospace$(last$) + comma$ + nospace$(first$)
  IF numberofrecords% <> 0 THEN
    inFile% = search%(target$)
  END IF

  IF inFile% THEN
    LOCATE 20, 25
    PRINT "That name is already on file";
    BEEP
   pause
    GOTO enddataentry
  END IF
  found.deleted% = 0
  found.deleted% = finddeleted%(getnum%)

  IF found.deleted% THEN
      numberofrecords% = numberofrecords% - 1
    recordnumber% = found.deleted%
  END IF

  PUT #1, recordnumber%, names
  numberofrecords% = numberofrecords% + 1
  reindex (target$)

ELSEIF UCASE$(ans$) = "N" THEN
  LOCATE 17, 30
  COLOR 1, 1
  PRINT SPACE$(15)
  COLOR 0, 3
  txt.edit temps$(), 9, 35, 0
  LOCATE , , 1, 7
  GOTO correct
ELSE
  GOTO correct
END IF
enddataentry:

END SUB

SUB db.index
    ' This routine can also be used in programs to reindex an .ndx file
    ' (created with the routines in this program) that has become corrupt.
    ' The database record file has to be intact.
    CLOSE
    CLS
    COLOR 15, 0
    center 12, "INDEXING DATABASE FILE"
    OPEN "names.dat" FOR RANDOM AS #1 LEN = (LEN(names))
    numberofrecords% = LOF(1) \ LEN(names)
    FOR i% = 1 TO numberofrecords%
      GET #1, i%, names
      index(i%).firstlast = UCASE$(LTRIM$(RTRIM$(names.last))) + comma$ + UCASE$(LTRIM$(RTRIM$(names.first)))
      index(i%).recordnumber = names.recnum
    NEXT i%
    sort
    updatendx
    CLOSE #1
    openfile
END SUB

SUB delete
' This routine does not physically delete records from the database record
' file.  Instead, it enters an ASCII 20 character for the first character
' of the indexed record and the database record.  These records are overlooked
' by any routines that display records or indexes, thus "deleting" them from
' the files.  They are physically removed when new records are added because
' they are overwritten by the new records.
COLOR 15, 1
CLS
border
center 25, "Delete this record ?  Y/N "
COLOR 0, 3
form
LOCATE 9, 35
PRINT names.first
LOCATE 10, 35
PRINT names.last
LOCATE 11, 35
PRINT names.address1
LOCATE 12, 35
PRINT names.address2;
LOCATE 25, 60
yesorno
IF yn$ = "N" THEN
  EXIT SUB
ELSEIF yn$ = "Y" THEN
  names.last = CHR$(20) + MID$(names.last, 2)
  PUT #1, temp(counter%).recordnumber, names
  counter% = temp(counter%).pointer
  index(counter%).firstlast = CHR$(20) + RTRIM$(LTRIM$(MID$(names.last, 2))) + comma$ + RTRIM$(LTRIM$(MID$(names.first, 1)))
  index(counter%).recordnumber = names.recnum
  sort
END IF
END SUB

SUB displaydata
LOCATE 25, 1
COLOR 15, 4
PRINT SPACE$(80);
COLOR 15, 1
CLS
COLOR 0, 3
form
LOCATE 9, 35
PRINT names.first
LOCATE 10, 35
PRINT names.last
LOCATE 11, 35
PRINT names.address1
LOCATE 12, 35
PRINT names.address2
pause

END SUB

SUB edit STATIC
' This routine calls txt.edit with the flag% value of 0 which means that the
' txt.edit sub starts in the overwrite mode as opposed to the insert mode
' that it starts in when flag% is set to 1 in the dataentry sub.
' I have not devised a method of checking for double entry if the first and
' last name are already on file because if data other than the names were
' changed here, the first and last names are already on file in the original
' copy of the record and the double entry check used in the DATAENTRY routine
' would not work here because it would always find a double entry.
' This is a good place for improvement.
COLOR 15, 1
CLS
message
COLOR 0, 3
form
LOCATE 9, 35
PRINT names.first
LOCATE 10, 35
PRINT names.last
LOCATE 11, 35
PRINT names.address1
LOCATE 12, 35
PRINT names.address2;

temps$(1) = names.first
temps$(2) = names.last
temps$(3) = names.address1
temps$(4) = names.address2

txt.edit temps$(), 9, 35, 0
switch names.recnum%

counter% = temp(counter%).pointer
index(counter%).firstlast = UCASE$(LTRIM$(RTRIM$(names.last))) + comma$ + UCASE$(LTRIM$(RTRIM$(names.first)))
PUT #1, names.recnum, names
sort
LOCATE , , 1, 7
END SUB

SUB endit

updatendx
CLOSE
COLOR 0, 7
CLS
COLOR 11, 0
LOCATE 10, 27
PRINT "■ MicroComputer Services ■"
END

END

END SUB

FUNCTION finddeleted% (getnum%)
' This routine searches the index array for records starting with ASCII 20
' and returns a non-zero (true) value to the dataentry sub.  This indicates
' to dataentry that there is a deleted record and it's record number is
' finddeleted% and to store the new record in the record number finddeleted%
getnum% = 0
del$ = CHR$(20)
FOR x% = 1 TO numberofrecords%
  indexname$ = index(x%).firstlast
  IF del$ = LEFT$(indexname$, 1) THEN
    getnum% = index(x%).recordnumber
    index(x%).firstlast = target$
    EXIT FOR
  END IF
NEXT x%

finddeleted% = getnum%


END FUNCTION

SUB form
'Prints a rectangle with name and address blank form.
box 8, 13, 15, 65, 1
FOR x% = 9 TO 12
  LOCATE x%, 16
  PRINT SPACE$(49);
NEXT x%
COLOR 0, 3
LOCATE 9, 16
PRINT "First Name:"
LOCATE 10, 16
PRINT "Last Name: "
LOCATE 11, 16
PRINT "Address: "
LOCATE 12, 16
PRINT "City, State  ZIP"


END SUB

SUB getname STATIC
'This routine puts 15 sorted names from the index into a box and allows the
'user to choose one with a bounce-bar.  User can see the next page or the
'previous page by using <N> and <P>,  correct name is highlighted and
'<RETURN> is pressed for record selection

nf% = 15: nb% = 1: rf% = 1: rb% = 7   'color assignment normal and reversed


top2: '*****************
COLOR , 0: CLS
border
LOCATE 25, 30
PRINT "Last Name: ";
LINE INPUT ; lastname$
COLOR 15, 4
LOCATE 25, 27
PRINT "<"; CHR$(24); "> or <"; CHR$(25); "> KEYS + ENTER";
COLOR nf%, nb%
box 5, 19, 25, 55, 0
counter% = 1
leng% = LEN(lastname$)
start% = 1
'***********************
searchstart:
row% = 5
second.counter% = 0
REDIM temp(1 TO UBOUND(index, 1)) AS indexrecord
'***********************
xstart:
FOR array% = start% TO UBOUND(index, 1)
    second.counter% = second.counter% + 1
    IF UCASE$(MID$(index(array%).firstlast, 1, leng%)) = UCASE$(lastname$) THEN
      IF UCASE$(LEFT$(index(array%).firstlast, 1)) = CHR$(20) THEN GOTO again
      LOCATE row%, 25
      PRINT index(array%).firstlast
      temp(counter%).firstlast = index(array%).firstlast
      temp(counter%).recordnumber = index(array%).recordnumber
      temp(counter%).pointer = array%
      row% = row% + 1
      counter% = counter% + 1
    IF counter% > 15 THEN
choice:         '***********
        LOCATE 25, 1
        COLOR 15, 4
        PRINT SPACE$(80);
        LOCATE 25, 5
        PRINT " <N>ext screen, <P>revious screen, <"; CHR$(24); "> , <"; CHR$(25); ">  <ESC> to end";
        GOTO bouncebar
    END IF
  END IF
again:
NEXT array%
IF counter% = 0 THEN
  COLOR 4, 7
  LOCATE , , 0
  center 25, "That name is not on file...  Please choose again"
  pause
  GOTO top2
END IF

bouncebar:   '************************** prints the highlighted bounce bar
temprow% = 5
endcounter% = counter% - 1
counter% = 1
IF temp(counter%).recordnumber = 0 THEN
  COLOR 15, 4
  center 25, "That name is not on file...   Please choose again"
  COLOR nf%, nb%
  pause
  GOTO top2
END IF

highlight
PRINT temp(counter%).firstlast;

DO
  DO
    keystroke$ = INKEY$
  LOOP WHILE keystroke$ = ""

  tempkey% = ASC(RIGHT$(keystroke$, 1))
  tempscankey% = ASC(LEFT$(keystroke$, 1))

  IF tempscankey% = 0 THEN
    SELECT CASE tempkey%
      CASE 72                           ' <UP>
        IF temprow% = 5 THEN
          lowlight
          PRINT temp(counter%).firstlast;
          temprow% = row% - 1
          counter% = endcounter%
          highlight
          PRINT temp(counter%).firstlast;

        ELSE
          temprow% = CSRLIN
          lowlight
          PRINT temp(counter%).firstlast;
          counter% = counter% - 1
          temprow% = temprow% - 1
          highlight
          PRINT temp(counter%).firstlast;

        END IF
      CASE 80      ' down
       temprow% = CSRLIN

        IF temprow% = row% - 1 THEN
          counter% = 1
          temprow% = row% - 1
          lowlight
          PRINT temp(endcounter%).firstlast;
          temprow% = 5
          counter% = 1
          highlight
          PRINT temp(counter%).firstlast;

        ELSE
          lowlight
          PRINT temp(counter%).firstlast;
          counter% = counter% + 1
          temprow% = temprow% + 1
          highlight
          PRINT temp(counter%).firstlast;
      END IF
    END SELECT
  ELSEIF tempscankey% <> 0 THEN
    SELECT CASE UCASE$(keystroke$)
      CASE IS = CHR$(27)
        VIEW PRINT
        menucall
      CASE IS = "P"
        COLOR nf%, nb%
        box 5, 19, 25, 55, 0
        counter% = 1
        row% = 5
        start% = start% - 15
        second.counter% = 0
        IF start% < 1 THEN
          COLOR 15, 4
          LOCATE 25, 1
          PRINT SPACE$(80);
          center 25, "Beginning of file"
          BEEP
          pause
          start% = 1
          COLOR nf%, nb%
        END IF
        GOTO xstart
      CASE IS = "N"
        IF array% > UBOUND(index, 1) THEN
          COLOR 15, 4
          LOCATE 25, 1
          PRINT SPACE$(80);
          center 25, "End of database file"
          BEEP
          pause
          LOCATE 25, 1
          PRINT SPACE$(80);
          LOCATE 25, 5
          PRINT " <N>ext screen, <P>revious screen, <"; CHR$(24); "> , <"; CHR$(25); ">  <ESC> to end";
          GOTO bouncebar
        END IF

        COLOR nf%, nb%
        box 5, 19, 25, 55, 0
        start% = second.counter% + 1
        second.counter% = 0
        counter% = 1
        row% = 5
        GOTO xstart
    END SELECT
  END IF
LOOP UNTIL keystroke$ = CHR$(13)
VIEW PRINT
GET #1, temp(counter%).recordnumber, names

END SUB

SUB highlight
  COLOR rf%, rb%
  LOCATE temprow%, 25, 0
  PRINT SPACE$(30);
  LOCATE temprow%, 25, 0
END SUB

SUB lowlight
  COLOR nf%, nb%
  LOCATE temprow%, 25, 0
  PRINT SPACE$(30);
  LOCATE temprow%, 25, 0
END SUB

SUB menu (fgd, bkgd, brdr)

'This is the famous bar-menu routine by Frank R. Neal of Columbus, Ohio.
'For specifics on it see one of the many QB menu programs on Compuserve, they
'all use a form of this routine.
'It returns the user's choice in the variable CHOICE%. Note that
'CHOICE% must be DIM'ed as a SHARED variable at the beginning of the program
'as does NP%.  NP% equals the number of menu choices available.
'The FBD, BKGD and BRDR parameters are the foreground, background and
'border colors of the menu printing. Note that BRDR = border color and is not
'supported by EGA VGA and MCGA adapters. see QuickBASIC version 4.0 BASIC
'Language Reference manual page 110.


COLOR fgd, bkgd, brdr
step1:
      row = 8: col = 20: '     SET ROW AND COLUMN FOR MENU
      C1F = fgd: C1B = bkgd'   SET COLOR CODES
      C2F = bkgd: C2B = fgd: '       SET BAR COLOR TO COLOR 0,2
step2:

GOSUB step3
      CLS
      GOTO menu.end
      GOTO step1
      GOTO step2
step3:
      COLOR C1F, C1B
      FOR J = 1 TO 16: x$ = INKEY$:  NEXT: choice% = 1
      LS = 2: FOR J = 1 TO np%: IF LEN(m$(J)) > LS THEN LS = LEN(m$(J))
      NEXT: ML$ = "##  \" + SPACE$(LS - 1) + "\": SL = col + 18 - LEN(ML$) / 2
      FOR K = 1 TO np%: LOCATE row + 2 + K, SL: PRINT USING ML$; K; m$(K): NEXT
step4:
  LOCATE row + 2 + choice%, SL: COLOR C2F, C2B: PRINT USING ML$; choice%; m$(choice%): COLOR C1F, C1B: TD = choice%
step5:
      x$ = INKEY$: IF LEN(x$) THEN KP = ASC(RIGHT$(x$, 1)) ELSE GOTO step5
      IF KP = 72 THEN choice% = choice% - 1: IF choice% < 1 THEN choice% = np%
      IF KP = 80 THEN choice% = choice% + 1: IF choice% > np% THEN choice% = 1
      IF x$ >= "1" AND x$ <= "9" THEN IF VAL(x$) >= 1 AND VAL(x$) <= np% THEN choice% = VAL(x$): RETURN
      IF KP = 13 THEN RETURN
      IF KP <> 72 AND KP <> 80 THEN KP = KP - 48: IF KP < 1 OR KP > np% THEN PRINT CHR$(7): GOTO step5 ELSE choice% = KP
      IF choice% = TD THEN GOTO step5 ELSE LOCATE row + 2 + TD, SL: PRINT USING ML$; TD; m$(TD): GOTO step4
menu.end:



END SUB

SUB menucall STATIC
'This starts the Main Menu of the program

thetop:

np% = 5
m$(1) = "Add a record"
m$(2) = "Find a record"
m$(3) = "Edit a record"
m$(4) = "Delete a record"
m$(5) = "Quit"

COLOR 14, 1
CLS
box 9, 17, 24, 51, 1
COLOR 15, 4
LOCATE 2, 25
PRINT "ADDRESS DATABASE MAIN MENU"
LOCATE 25, 1
COLOR 15, 4
FOR x% = 1 TO 80
  PRINT CHR$(32);
NEXT x%
LOCATE 25, 27
PRINT "<"; CHR$(24); "> or <"; CHR$(25); "> KEYS + ENTER";
COLOR 14, 1
LOCATE , , 0
menu 7, 1, 1
LOCATE , , 1
ON choice% GOTO datain, find, edit, delete, enditall

datain:
dataentry
GOTO thetop

find:
getname
displaydata
GOTO thetop

edit:
getname
edit
GOTO thetop

delete:
getname
delete
GOTO thetop

enditall:
endit

END SUB

SUB message
COLOR 15, 4
LOCATE 25, 1
PRINT "CURSOR KEYS:<"; CHR$(24); "> <"; CHR$(25); "> <"; CHR$(27); "> <"; CHR$(26); "> <INS> <DEL> <HOME> <END> <PGUP> <PGDN> ;<ESC> aborts";
END SUB

FUNCTION nospace$ (searchstring$)
' This function removes any spaces from the index arrays.

searchstring$ = UCASE$(LTRIM$(RTRIM$(searchstring$)))
tempstring$ = ""
FOR i% = 1 TO LEN(searchstring$)
  oneChar$ = MID$(searchstring$, i%, 1)
  IF oneChar$ <> CHR$(32) THEN
    tempstring$ = tempstring$ + oneChar$
  END IF
NEXT i%
nospace$ = tempstring$
END FUNCTION

SUB openfile

OPEN "names.dat" FOR RANDOM AS #1 LEN = (LEN(names))
numberofrecords% = LOF(1) \ LEN(names)
recordnumber% = numberofrecords%
IF recordnumber% > 0 THEN openindex

END SUB

SUB openindex
REDIM index(numberofrecords%) AS indexrecord
OPEN "names.ndx" FOR INPUT AS #2
FOR indexnum% = 1 TO numberofrecords%
  INPUT #2, index(indexnum%).firstlast, index(indexnum%).recordnumber
NEXT indexnum%
CLOSE #2
END SUB

SUB pause
WHILE INKEY$ = ""
WEND
END SUB

SUB reindex (target$) STATIC
'This routine adds the new index entry to the index array.

IF found.deleted% = false% THEN
  IF numberofrecords% > 1 THEN
    oldtot% = numberofrecords% - 1
    REDIM tempindex(oldtot%) AS indexrecord
    FOR i% = 1 TO oldtot%
      tempindex(i%) = index(i%)
    NEXT i%
  END IF

  REDIM index(numberofrecords%)  AS indexrecord

  IF numberofrecords% > 1 THEN

    FOR i% = 1 TO oldtot%
      index(i%) = tempindex(i%)
    NEXT i%
  END IF
  index(numberofrecords%).firstlast = target$
  index(numberofrecords%).recordnumber = numberofrecords%
END IF

  sort

END SUB

FUNCTION search% (whatText$) STATIC
' This routine searches the index array for duplicate entries
begin% = 1
ending% = numberofrecords%
located% = false%
getnum% = 0
DO WHILE begin% <= ending% AND NOT located%
  middle% = (begin% + ending%) \ 2
  indexname$ = RTRIM$(index(middle%).firstlast)
  IF whatText$ = indexname$ THEN
    located% = true%
    getnum% = index(middle%).recordnumber
  ELSEIF whatText$ > indexname$ THEN
    begin% = middle% + 1
  ELSE
    ending% = middle% - 1
  END IF
LOOP
search% = getnum%

END FUNCTION

SUB sort STATIC
' SHELL SORT routine
length% = numberofrecords%
jump% = 1
DO WHILE jump% <= length%
  jump% = jump% * 2
LOOP
DO WHILE jump% > 1
  jump% = (jump% - 1) \ 2
  DO
    finished% = true%
    FOR upper% = 1 TO length% - jump%
      lower% = upper% + jump%
      IF index(upper%).firstlast > index(lower%).firstlast THEN
        SWAP index(upper%), index(lower%)
        finished% = false%
      END IF
    NEXT upper%
  LOOP UNTIL finished%
LOOP
END SUB

SUB switch (number%)
names.first = temps$(1)
names.last = temps$(2)
names.address1 = temps$(3)
names.address2 = temps$(4)
names.recnum = number%
END SUB

SUB txt.edit (temps$(), fieldrow%, fieldcol%, flag%) STATIC

'This routine saves keyboard entry into a memory array, it allows full cursor
'control with up & down arrow, page up & down, insert, home, end, right and
' left arrows.
' flag% is either 1 or 0, cursor starts in insert mode or overwrite mode
rownum% = fieldrow%                               'constant row number
colnum% = fieldcol%                               'constant column number
IF flag% THEN
  FOR num% = 1 TO UBOUND(temps$, 1)                  ' add a space to each field
    temps$(num%) = CHR$(32) + MID$(temps$(num%), 2)   ' to use later for testing
  NEXT num%                                         ' if field contains data
END IF
num% = 1
DO WHILE num% <= UBOUND(temps$, 1)
  IF num% > UBOUND(temps$, 1) THEN EXIT DO
    length% = LEN(temps$(num%))
  IF LEFT$(temps$(num%), 1) = CHR$(32) THEN        'is the field empty, if so
    temps$(num%) = SPACE$(length%)                 ' add a value to temps$(num%)
  ELSE
  END IF
  IF flag% = 1 THEN                              'insert mode
    LOCATE fieldrow%, fieldcol%, 1, 7
  ELSE                                           'overstrike mode
    LOCATE fieldrow%, fieldcol%, 1, 0, 7
  END IF
  entry$ = ""
  DO UNTIL entry$ = CHR$(13) OR entry$ = CHR$(0) + CHR$(72) OR entry$ = CHR$(0) + CHR$(80) OR entry$ = CHR$(0) + CHR$(73) OR entry$ = CHR$(0) + CHR$(81)
      DO
        entry$ = INKEY$             'get keyboard entry
      LOOP WHILE entry$ = ""
      keys% = ASC(RIGHT$(entry$, 1))
      scankey% = ASC(LEFT$(entry$, 1))
    IF scankey% = 0 THEN
      SELECT CASE keys%
        CASE 72                     '<UP ARROW> key
          IF fieldrow% - 1 < rownum% THEN
            num% = UBOUND(temps$, 1)
            fieldrow% = rownum% + (UBOUND(temps$, 1) - 1)
            LOCATE fieldrow%, colnum%
            EXIT DO
          ELSEIF POS(0) > colnum% + LEN(temps$(num% - 1)) THEN
            num% = num% - 1
            fieldrow% = fieldrow% - 1
            LOCATE fieldrow%, colnum% + LEN(temps$(num%)) - 1
            EXIT DO
          ELSE
            fieldrow% = fieldrow% - 1
            num% = num% - 1
            LOCATE fieldrow%, POS(0)
            EXIT DO
          END IF
        CASE 75                    '<LEFT ARROW> key
          IF POS(0) = colnum% THEN
            BEEP
          ELSE
            LOCATE fieldrow%, POS(0) - 1
          END IF
          temps$(num%) = temps$(num%)
        CASE 77                     '<RIGHT ARROW> key
          IF POS(0) = colnum% + (LEN(temps$(num%)) - 1) THEN
            LOCATE fieldrow%, POS(0)
            BEEP
          ELSE LOCATE fieldrow%, POS(0) + 1
          END IF
        CASE 80                     '<DOWN ARROW> key
          IF fieldrow% >= rownum% + UBOUND(temps$, 1) - 1 THEN
            num% = LBOUND(temps$, 1)
            fieldrow% = rownum%
            LOCATE fieldrow%, colnum%
            EXIT DO
          ELSEIF POS(0) > colnum% + LEN(temps$(num% + 1)) THEN
            num% = num% + 1
            fieldrow% = fieldrow% + 1
            LOCATE fieldrow%, colnum% + LEN(temps$(num%)) - 1
            EXIT DO
          ELSE
            num% = num% + 1
            fieldrow% = fieldrow% + 1
            LOCATE fieldrow%, POS(0)
            EXIT DO
          END IF
          temps$(num%) = temps$(num%) + CHR$(32)
        CASE 73                     '<PG UP> key
          IF num% = LBOUND(temps$, 1) THEN
            LOCATE rownum%, colnum%
            EXIT DO
          ELSE
            num% = LBOUND(temps$, 1)
            fieldrow% = rownum%
            LOCATE rownum%, colnum%
            EXIT DO
          END IF
        CASE 81                      '<PG DN> key
          IF num% = UBOUND(temps$, 1) THEN
            LOCATE fieldrow%, colnum%
            EXIT DO
          ELSE
            num% = UBOUND(temps$, 1)
            fieldrow% = rownum% + (UBOUND(temps$, 1) - 1)
            LOCATE fieldrow%, colnum%
            EXIT DO
          END IF
        CASE 83                     ' <DEL> key
          delpos% = POS(0)
          L$ = LEFT$(temps$(num%), POS(0) - colnum%)
          r$ = RIGHT$(temps$(num%), (length% - (POS(0) - colnum%)) - 1)
          temps$(num%) = L$ + r$ + CHR$(32)
          LOCATE fieldrow%, colnum%
          PRINT SPACE$(length%);
          LOCATE fieldrow%, colnum%
          PRINT temps$(num%);
          LOCATE fieldrow%, delpos%
        CASE 71                     '<HOME> key - goto beginning of field
          LOCATE fieldrow%, colnum%
        CASE 79                     '<END> key - goto end of data
          IF (INSTR((POS(0) + 1) - colnum%, temps$(num%), CHR$(32))) <> 0 THEN
            advance% = POS(0) + (INSTR(temps$(num%), CHR$(32)))
            LOCATE fieldrow%, advance%
          IF advance% >= length% + colnum% THEN LOCATE fieldrow%, (length% + colnum%) - 1
          ELSE
            LOCATE fieldrow%, (length% + colnum%) - 1
          END IF
        CASE 82                                   '<INS> key
          IF flag% = 0 THEN                       'overstrike mode on
            LOCATE fieldrow%, POS(0), , 7         'turn on insert cursor
            flag% = 1                             'turn on insert mode
          ELSEIF flag% = 1 THEN                   'insert mode is on
            LOCATE fieldrow%, POS(0), 1, 0, 7     'turn on overstrike cursor
            flag% = 0                             'turn on overstrike mode
          END IF
      END SELECT
    ELSEIF scankey% <> 0 THEN
      SELECT CASE keys%
        CASE 27                                     '<ESC>
          menucall
        CASE 13                                     '<CR>
          LOCATE fieldrow%, colnum%
          PRINT temps$(num%);
          fieldrow% = fieldrow% + 1                 'go to next field
          num% = num% + 1
          LOCATE fieldrow%, colnum%
          EXIT DO
        CASE 8                                      '<BKSP> key
          position% = POS(0)
          IF position% = colnum% THEN               'at first position
            LOCATE fieldrow%, POS(0)                'in field
          ELSEIF position% > colnum% THEN
            L$ = LEFT$(temps$(num%), position% - colnum% - 1)
            r$ = RIGHT$(temps$(num%), length% - (position% - colnum%))
            temps$(num%) = L$ + r$ + CHR$(32)
            LOCATE fieldrow%, colnum%
            PRINT SPACE$(length%)
            LOCATE fieldrow%, colnum%
            PRINT temps$(num%);
            LOCATE fieldrow%, position% - 1
          END IF
        CASE ELSE                   'entry$ is alphanumeric
           IF entry$ > CHR$(20) AND entry$ < CHR$(127) THEN
              IF flag% = 1 AND LEN(RTRIM$(temps$(num%))) < length% THEN  'insert mode on
                insertsite% = POS(0)                          'and check for full field
                temps$(num%) = LEFT$(temps$(num%), insertsite% - colnum%) + entry$ + MID$(temps$(num%), insertsite% - colnum% + 1)
                temps$(num%) = RTRIM$(temps$(num%)) + SPACE$(length% - LEN(RTRIM$(temps$(num%))))
                LOCATE fieldrow%, colnum%
                PRINT RTRIM$(temps$(num%))
                LOCATE fieldrow%, insertsite% + 1
              ELSE                  'overwrite mode on
                PRINT entry$;
                MID$(temps$(num%), (POS(0) - colnum%), 1) = entry$
              END IF
           END IF
            IF RIGHT$(temps$(num%), 1) <> CHR$(32) AND RIGHT$(temps$(num%), 1) <> CHR$(0) OR LEN(RTRIM$(temps$(num%))) >= length% THEN
              BEEP
              fieldrow% = fieldrow% + 1
              num% = num% + 1
              LOCATE fieldrow%, colnum%, 1
              EXIT DO
             END IF
      END SELECT
    END IF
  LOOP
LOOP

END SUB

SUB updatendx STATIC
' This routine updates the disk index file from the index memory array.
IF numberofrecords% > 0 THEN
  OPEN "names.ndx" FOR OUTPUT AS #2
  FOR i% = 1 TO numberofrecords%
    WRITE #2, RTRIM$(index(i%).firstlast), index(i%).recordnumber
  NEXT i%
  CLOSE #2
END IF
END SUB

SUB yesorno

'This simple routine gets a "Y" or "N" response to a yes/no question
'and returns it to the caller in variable YN$. Note that YN$ must
'be DIM'ed as a SHARED variable at the beginning of the program.


answer.please:
     yn$ = INKEY$: IF yn$ = "" THEN GOTO answer.please
     IF INSTR("YyNn", yn$) = 0 THEN GOTO answer.please
     yn$ = UCASE$(yn$)

END SUB